home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / tbsrc / file1.bas < prev    next >
BASIC Source File  |  1994-10-09  |  6KB  |  156 lines
  1. Option Explicit
  2.  
  3. Type apiRect
  4.     left                    As Integer
  5.     top                     As Integer
  6.     right                   As Integer
  7.     bottom                  As Integer
  8. End Type
  9. Type apiPoint
  10.     X                       As Integer
  11.     Y                       As Integer
  12. End Type
  13.  
  14. Global MP_Alt               As Integer
  15. Global Const BUTTON_FACE = &H8000000F           ' Face shading on command buttons.
  16. Global Const srcCopy = &HCC0020
  17. Declare Function GetSysColor Lib "User" (ByVal nIndex As Integer) As Long
  18. Declare Function GetSystemMetrics Lib "user" (ByVal Param As Integer) As Integer
  19. Declare Function StretchBlt Lib "GDI" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal nSrcWidth%, ByVal nSrcHeight%, ByVal dwRop&) As Integer
  20.  
  21. Declare Function CreateDC Lib "GDI" (ByVal Driver$, ByVal Dev&, ByVal O&, ByVal init&) As Integer
  22. Declare Function DeleteDC Lib "GDI" (ByVal dc As Integer) As Integer
  23. Declare Sub DrawFocusRect Lib "User" (ByVal hDC As Integer, lpRect As apiRect)
  24. Declare Function GetKeyState Lib "User" (ByVal nVirtKey As Integer) As Integer
  25. Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  26. Declare Function GetTickCount Lib "user" () As Long
  27. Declare Function DrawIcon Lib "User" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer) As Integer
  28. Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lpRect As apiRect)
  29. Declare Sub GetCursorPos Lib "User" (sPoint As apiPoint)
  30.  
  31. Declare Function GetMenu Lib "User" (ByVal hWnd As Integer) As Integer
  32. Declare Sub ClipCursor Lib "User" (lpRect As apiRect)
  33. Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
  34.  
  35. Sub MakeLowerStatusBar (Bar As PictureBox)
  36. Dim OldParentMode As Integer, MyOldMode As Integer, MDICorr As Integer
  37. Dim OldRedraw As Integer, wRect As apiRect, Col As Long
  38.     If Bar.Align = 2 Then
  39.         OldRedraw = Bar.AutoRedraw
  40.         Bar.AutoRedraw = True
  41.         Bar.BackColor = BUTTON_FACE'GetSysColor(15)
  42.         Bar.BorderStyle = False
  43.         GetWindowRect Bar.hWnd, wRect
  44.         MyOldMode = Bar.ScaleMode
  45.         Bar.ScaleMode = 3
  46.         Col = GetSysColor(20)
  47.         Bar.Line (0, 1)-(wRect.right - wRect.left, 1), Col
  48.         Bar.Line (0, 2)-(0, wRect.bottom - wRect.top), Col
  49.         Col = GetSysColor(16)
  50.         Bar.Line (1, wRect.bottom - wRect.top - 1)-(wRect.right - wRect.left, wRect.bottom - wRect.top - 1), Col
  51.         Bar.Line (0, 0)-(wRect.right - wRect.left, 0), RGB(0, 0, 0)
  52.         If MDICorr = 1 Then
  53.             Bar.Parent.ScaleMode = OldParentMode
  54.         End If
  55.         Bar.ScaleMode = MyOldMode
  56.         Bar.AutoRedraw = OldRedraw
  57.     Else
  58.         MakeUpperStatusBar Bar
  59.     End If
  60. End Sub
  61.  
  62. Sub MakeStatusBar (Bar As PictureBox)
  63.     If Bar.Align = 2 Then
  64.         MakeLowerStatusBar Bar
  65.     Else
  66.         MakeUpperStatusBar Bar
  67.     End If
  68. End Sub
  69.  
  70. Sub MakeUpperStatusBar (Bar As PictureBox)
  71. Dim OldParentMode As Integer, MyOldMode As Integer, MDICorr As Integer
  72. Dim OldRedraw As Integer, wRect As apiRect, Col As Long
  73.     If Bar.Align = 1 Then
  74.         OldRedraw = Bar.AutoRedraw
  75.         Bar.AutoRedraw = True
  76.         Bar.BackColor = BUTTON_FACE'GetSysColor(15)
  77.         Bar.BorderStyle = False
  78.         GetWindowRect Bar.hWnd, wRect           '<<<!!!
  79.         MyOldMode = Bar.ScaleMode
  80.         Bar.ScaleMode = 3
  81.         Col = GetSysColor(20)
  82.         Bar.Line (0, 0)-(wRect.right - wRect.left, 0), Col
  83.         Bar.Line (0, 1)-(0, wRect.bottom - wRect.top), Col
  84.         Col = GetSysColor(16)
  85.         Bar.Line (1, wRect.bottom - wRect.top - 2)-(wRect.right - wRect.left, wRect.bottom - wRect.top - 2), Col
  86.         Bar.Line (0, wRect.bottom - wRect.top - 1)-(wRect.right - wRect.left, wRect.bottom - wRect.top - 1), RGB(0, 0, 0)
  87.         If MDICorr = 1 Then
  88.             Bar.Parent.ScaleMode = OldParentMode
  89.         End If
  90.         Bar.ScaleMode = MyOldMode
  91.         Bar.AutoRedraw = OldRedraw
  92.     Else
  93.         MakeLowerStatusBar Bar
  94.     End If
  95. End Sub
  96.  
  97. Sub SizeControl (MyControl As Control)
  98. Dim rl As Long
  99.     On Error Resume Next
  100.     MyControl.Width = MyControl.Parent.ScaleWidth - MyControl.Left
  101.     MyControl.Height = MyControl.Parent.ScaleHeight - MyControl.Top
  102. End Sub
  103.  
  104. Sub WaitZehntel (Sec As Integer)
  105. Dim StartZeit!, StoppZeit!
  106.     StartZeit! = GetTickCount() / 1000
  107.     Do
  108.     StoppZeit! = GetTickCount() / 1000
  109.     DoEvents
  110.     If StartZeit! + (Sec / 10) <= StoppZeit! Then Exit Do
  111.     Loop
  112. End Sub
  113.  
  114. Sub zGetInnerRect (MyForm As Form, MyRect As apiRect)
  115. Dim a As Integer, b As Integer, c As Integer, d As Integer, MyMenu As Integer
  116. Dim bs As Integer
  117.     GetWindowRect MyForm.hWnd, MyRect
  118.     MyMenu = GetMenu(MyForm.hWnd)
  119.     If MyMenu < 0 Then MyMenu = 0
  120.     If TypeOf MyForm Is MDIForm Then
  121.     bs = 2
  122.     Else
  123.     bs = MyForm.BorderStyle
  124.     End If
  125.     Select Case bs
  126.     Case 0  ' ohne Rand
  127.         a = 0
  128.         b = 0
  129.         c = 0
  130.         d = 0
  131.     Case 1  ' mit einfachem Rand
  132.         a = GetSystemMetrics(5)
  133.         b = GetSystemMetrics(4)
  134.         If MyMenu Then b = b + GetSystemMetrics(15)
  135.         c = a
  136.         d = GetSystemMetrics(6)
  137.     Case 2  ' mit normalem Rand
  138.         a = GetSystemMetrics(32)
  139.         b = GetSystemMetrics(33) + GetSystemMetrics(4) - GetSystemMetrics(6)
  140.         If MyMenu Then b = b + GetSystemMetrics(15)
  141.         c = a
  142.         d = GetSystemMetrics(32)
  143.     Case 3  ' mit doppeltem Rand
  144.         a = GetSystemMetrics(7)
  145.         b = GetSystemMetrics(8) + GetSystemMetrics(4) - GetSystemMetrics(6)
  146.         If MyMenu Then b = b + GetSystemMetrics(15)
  147.         c = a
  148.         d = GetSystemMetrics(8)
  149.     End Select
  150.     MyRect.left = MyRect.left + a
  151.     MyRect.top = MyRect.top + b
  152.     MyRect.right = MyRect.right - c
  153.     MyRect.bottom = MyRect.bottom - d
  154. End Sub
  155.  
  156.